Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/runner1a/shortcre.bas

BASIC Source File | 1999-09-14 | 12KB | 335 lines

Attribute VB_Name = "ShrtCut"
Private Const kQuote = """"
Private Const kEmptyString = ""
Private Const kMaxPathLength = 260 ' Maximum allowed path & filename length.
Private Const kMaxGroupNameLength = 30 ' NT Maximum length that we allow for an group name.
Private Const kInvalid95GroupNameChars = "\/:*?""<>|" ' Invalid Windows 95 Group Name Characters.
Private Const kInvalidNTGroupNameChars = """][,)(" ' Invalid Windows NT Group Name Characters.
Private Const kDesktopGroup = "..\..\DESKTOP" ' Desktop Group.
Private Const kStartMenuGroup = ".." ' Start Menu Group.
'     'PROGRAM MANAGER ACTIONS'
Const kDDE_AddItem = 1 'AddProgManItem flag
Const kDDE_AddGroup = 2 'AddProgManGroup flag
'     'Other functions'
Declare Function GetWinPlatform Lib "VB5STKIT.DLL" () As Long

Declare Function fNTWithShell Lib "VB5STKIT.DLL" () As Boolean

Private Declare Function OSGetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Declare Function OSfCreateShellGroup Lib "VB5STKIT.DLL" Alias "fCreateShellFolder" (ByVal lpstrDirName As String) As Long

Declare Function OSfCreateShellLink Lib "VB5STKIT.DLL" Alias "fCreateShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String) As Long

Declare Function OSfRemoveShellLink Lib "VB5STKIT.DLL" Alias "fRemoveShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String) As Long
Public Sub CreateShortcut(ByRef frm As Form, ByVal strGroupName As String, ByVal strLinkName As String, ByVal strLinkPath As String, ByVal strLinkArguments As String)
              If fCreateProgGroup(frm, strGroupName) Then

                            If TreatAsWin95() Then

                                   CreateShellLink strLinkPath, strGroupName, strLinkArguments, strLinkName
                            Else

                                   strLinkPath = GetShortPathName(strUnQuoteString(strLinkPath))
                                   CreateProgManItem frm, strGroupName, strLinkPath & " " & strLinkArguments, strLinkName
                            End If

              End If

End Sub


Private Sub CreateShellLink(ByVal strLinkPath As String, ByVal strGroupName As String, ByVal strLinkArguments As String, ByVal strLinkName As String)
       strLinkName = strUnQuoteString(strLinkName)
       strLinkPath = strUnQuoteString(strLinkPath)
       Dim fSuccess As Boolean
       fSuccess = OSfCreateShellLink(strGroupName & "", strLinkName, strLinkPath, strLinkArguments & "")

              If Not fSuccess Then
                     MsgBox "Create Shortcut Failed!", vbExclamation, "Ouch!"
              End If

End Sub


Private Sub CreateProgManItem(frm As Form, ByVal strGroupName As String, ByVal strCmdLine As String, ByVal strIconTitle As String)

       PerformDDE frm, strGroupName, strCmdLine, strIconTitle, kDDE_AddItem
End Sub


Private Sub PerformDDE(frm As Form, ByVal strGroup As String, ByVal strCmd As String, ByVal strTitle As String, ByVal intDDE As Integer)

       Const strCOMMA$ = ","
       Const strRESTORE$ = ", 1)]"
       Const strACTIVATE$ = ", 5)]"
       Const strENDCMD$ = ")]"
       Const strSHOWGRP$ = "[ShowGroup("
       Const strADDGRP$ = "[CreateGroup("
       Const strREPLITEM$ = "[ReplaceItem("
       Const strADDITEM$ = "[AddItem("
       Dim intIdx As Integer
       Screen.MousePointer = vbHourglass
       Dim intRetry As Integer

              For intRetry = 1 To 20
                     On Error Resume Next
                     frm.lblDDE.LinkTopic = "PROGMAN|PROGMAN"

                            If Err = 0 Then
                                   Exit For
                            End If


                            DoEvents
                            Next intRetry

                     frm.lblDDE.LinkMode = 2

                            For intIdx = 1 To 10
                                    DoEvents
                            Next

                     frm.lblDDE.LinkTimeout = 100
                     On Error Resume Next

                            If Err = 0 Then
                                   Select Case intDDE
                                   Case kDDE_AddItem

                                          #If 0 Then
                                                 frm.lblDDE.LinkExecute strSHOWGRP & strGroup & strACTIVATE
                                          #Else
                                                 frm.lblDDE.LinkExecute strADDGRP & strGroup & strENDCMD
                                          #End If

                                   frm.lblDDE.LinkExecute strREPLITEM & strTitle & strENDCMD
                                   Err = 0
                                   frm.lblDDE.LinkExecute strADDITEM & strCmd & strCOMMA & strTitle & String$(3, strCOMMA) & strENDCMD
                                   Case kDDE_AddGroup
                                   frm.lblDDE.LinkExecute strADDGRP & strGroup & strENDCMD
                                   frm.lblDDE.LinkExecute strSHOWGRP & strGroup & strRESTORE

                            End Select

              End If

       frm.lblDDE.LinkMode = 0
       frm.lblDDE.LinkTopic = ""
       Screen.MousePointer = vbDefault
       Err = 0
End Sub
Private Function fCreateProgGroup(frm As Form, sNewGroupName As String) As Boolean

              If UCase(Trim(sNewGroupName)) = kDesktopGroup Or sNewGroupName = kStartMenuGroup Then
                     fCreateProgGroup = True
                     Exit Function
              Else

                            If TreatAsWin95() Then


                                          If Not fValid95Filename(sNewGroupName) Then
                                                 MsgBox "Error: Could not validate the Program Group name!", vbQuestion, "Error"
                                                 GoTo CGError
                                          End If

                            Else


                                          If Not fValidNTGroupName(sNewGroupName) Then
                                                 MsgBox "Error: Could not validate the Program Group name!", vbQuestion, "Error"
                                                 GoTo CGError
                                          End If

                            End If

                            If Not fCreateOSProgramGroup(frm, sNewGroupName) Then
                                   GoTo CGError
                            End If

                     fCreateProgGroup = True
              End If

       Exit Function
CGError:
       fCreateProgGroup = False
End Function


Private Function fCreateShellGroup(ByVal strFolderName As String) As Boolean

       ReplaceDoubleQuotes strFolderName

              If strFolderName = "" Then
                     Exit Function
              End If

       Dim fSuccess As Boolean
       fSuccess = OSfCreateShellGroup(strFolderName)

              If fSuccess Then
              Else
                     MsgBox "Create Start Menu Group Failed!", vbExclamation, "Ouch!"
              End If

       fCreateShellGroup = fSuccess
End Function


Private Function fValid95Filename(strFilename As String) As Boolean

       Dim iInvalidChar As Integer
       Dim iFilename As Integer

              If Not ValidateFilenameLength(strFilename) Then
                     fValid95Filename = False
                     Exit Function
              End If

              For iInvalidChar = 1 To Len(kInvalid95GroupNameChars)

                            If InStr(strFilename, Mid$(kInvalid95GroupNameChars, iInvalidChar, 1)) <> 0 Then
                                   fValid95Filename = False
                                   Exit Function